home *** CD-ROM | disk | FTP | other *** search
/ Aminet 21 / Aminet 21 (1997)(GTI - Schatztruhe)[!][Oct 1997].iso / Aminet / gfx / show / gs503_data.lha / Ghostscript / data / font2c.ps < prev    next >
Text File  |  1997-08-14  |  20KB  |  687 lines
  1. %    Copyright (C) 1992, 1993, 1994, 1995 Aladdin Enterprises.  All rights reserved.
  2. % 
  3. % This file is part of Aladdin Ghostscript.
  4. % 
  5. % Aladdin Ghostscript is distributed with NO WARRANTY OF ANY KIND.  No author
  6. % or distributor accepts any responsibility for the consequences of using it,
  7. % or for whether it serves any particular purpose or works at all, unless he
  8. % or she says so in writing.  Refer to the Aladdin Ghostscript Free Public
  9. % License (the "License") for full details.
  10. % 
  11. % Every copy of Aladdin Ghostscript must include a copy of the License,
  12. % normally in a plain ASCII text file named PUBLIC.  The License grants you
  13. % the right to copy, modify and redistribute Aladdin Ghostscript, but only
  14. % under certain conditions described in the License.  Among other things, the
  15. % License requires that the copyright notice and this notice be preserved on
  16. % all copies.
  17.  
  18. % font2c.ps
  19. % Write out a PostScript Type 0 or Type 1 font as C code
  20. % that can be linked with the interpreter.
  21. % This even works on protected fonts, if you use the -dWRITESYSTEMDICT
  22. % switch in the command line.  The code is reentrant and location-
  23. % independent and has no external references, so it can be put into
  24. % a sharable library even on VMS.
  25.  
  26. % Define the maximum string length that all compilers will accept.
  27. % This must be approximately
  28. %    min(max line length, max string literal length) / 4 - 5.
  29.  
  30. /font2cdict 100 dict dup begin
  31.  
  32. /max_wcs 50 def
  33.  
  34. % Define a temporary file for writing out procedures.
  35. /wtempname (_.tmp) def
  36.  
  37. % ------ Protection utilities ------ %
  38.  
  39. % Protection values are represented by a mask:
  40. /a_noaccess 0 def
  41. /a_executeonly 1 def
  42. /a_readonly 3 def
  43. /a_all 7 def
  44. /prot_names
  45.  [ (0) (a_execute) null (a_readonly) null null null (a_all)
  46.  ] def
  47. /prot_opers
  48.  [ {noaccess} {executeonly} {} {readonly} {} {} {} {}
  49.  ] def
  50.  
  51. % Get the protection of an object.
  52.    /getpa
  53.     { dup wcheck
  54.        { pop a_all }
  55.        {    % Check for executeonly or noaccess objects in protected.
  56.          dup protected exch known
  57.       { protected exch get }
  58.       { pop a_readonly }
  59.      ifelse
  60.        }
  61.       ifelse
  62.     } bind def
  63.  
  64. % Get the protection appropriate for (all the) values in a dictionary.
  65.    /getva
  66.     { a_noaccess exch
  67.        { exch pop
  68.          dup type dup /stringtype eq 1 index /arraytype eq or
  69.      exch /packedarraytype eq or
  70.       { getpa a_readonly and or }
  71.       { pop pop a_all exit }
  72.      ifelse
  73.        }
  74.       forall
  75.     } bind def
  76.  
  77. % Keep track of executeonly and noaccess objects,
  78. % but don't let the protection actually take effect.
  79. .currentglobal
  80. false .setglobal    % so protected can reference local objs
  81. /protected        % do first so // will work
  82.   systemdict wcheck { 1500 dict } { 1 dict } ifelse
  83. def
  84. systemdict wcheck not
  85.  { (Warning: you will not be able to convert protected fonts.\n) print
  86.    (If you need to convert a protected font, please\n) print
  87.    (restart the program and specify the -dWRITESYSTEMDICT switch.\n) print
  88.    flush
  89.    (%end) .skipeof
  90.  }
  91. if
  92. userdict begin
  93.   /executeonly
  94.    { dup //protected exch //a_executeonly put readonly
  95.    } bind def
  96.   /noaccess
  97.    { dup //protected exch //a_noaccess put readonly
  98.    } bind def
  99. end
  100. true .setglobal
  101. systemdict begin
  102.   /executeonly
  103.    { userdict /executeonly get exec
  104.    } bind odef
  105.   /noaccess
  106.    { userdict /noaccess get exec
  107.    } bind odef
  108. end
  109. %end
  110. .setglobal
  111.  
  112. % ------ Output utilities ------ %
  113.  
  114. % By convention, the output file is named cfile.
  115.  
  116. % Define some utilities for writing the output file.
  117.    /wtstring 100 string def
  118.    /wb {cfile exch write} bind def
  119.    /ws {cfile exch writestring} bind def
  120.    /wl {ws (\n) ws} bind def
  121.    /wt {wtstring cvs ws} bind def
  122.  
  123. % Write a C string.  Some compilers have unreasonably small limits on
  124. % the length of a string literal or the length of a line, so every place
  125. % that uses wcs must either know that the string is short,
  126. % or be prepared to use wcca instead.
  127.    /wbx
  128.     { 8#1000 add 8 (0000) cvrs dup 0 (\\) 0 get put ws
  129.     } bind def
  130.    /wcst
  131.     [
  132.       32 { /wbx load } repeat
  133.       95 { /wb load } repeat
  134.       129 { /wbx load } repeat
  135.     ] def
  136.    ("\\) { wcst exch { (\\) ws wb } put } forall
  137.    /wcs
  138.     { (") ws { dup wcst exch get exec } forall (") ws
  139.     } bind def
  140.    /can_wcs    % Test if can use wcs
  141.     { length max_wcs le
  142.     } bind def
  143.    /wncs    % name -> C string
  144.     { wtstring cvs wcs
  145.     } bind def
  146. % Write a C string as an array of character values.
  147. % We only need this because of line and literal length limitations.
  148.    /wca        % <string> <prefix> <suffix> wca -
  149.     { 0 4 -2 roll exch
  150.        {    % Stack: suffix n prefix char
  151.      exch ws
  152.      exch dup 19 ge { () wl pop 0 } if 1 add
  153.      exch dup 32 ge 1 index 126 le and
  154.       { 39 wb dup 39 eq 1 index 92 eq or { 92 wb } if wb 39 wb }
  155.       { wt }
  156.      ifelse (,)
  157.        } forall
  158.       pop pop ws
  159.     } bind def
  160.    /wcca    % <string> wcca -
  161.     { ({\n) (}) wca
  162.     } bind def
  163.  
  164. % Write object protection attributes.  Note that dictionaries and arrays are
  165. % the only objects that can be writable.
  166.    /wpa
  167.     { dup xcheck { (a_executable|) ws } if
  168.       dup type dup /dicttype eq exch /arraytype eq or
  169.        { getpa }
  170.        { getpa a_readonly and }
  171.       ifelse prot_names exch get ws
  172.     } bind def
  173.    /wva
  174.     { getva prot_names exch get ws
  175.     } bind def
  176.  
  177. % ------ Object writing ------ %
  178.  
  179.    /wnstring 128 string def
  180.  
  181. % Convert an object to a string to be scanned at a later time.
  182.    /cvos        % <obj> cvos <string>
  183.     {        % We'd like to use == and write directly to a string,
  184.         % but we can't do the former because of operators,
  185.         % and we can't do the latter because we can't predict
  186.         % how long the string would have to be....
  187.      wtempname (w) file dup 3 -1 roll wproc closefile
  188.      wtempname status pop pop pop exch pop string
  189.      wtempname (r) file dup 3 -1 roll readstring pop exch closefile
  190.     } bind def
  191.  
  192. % Write a string/name or null as an element of a string/name/null array.
  193. % Convert any other kind of value to a token to be read back in.
  194.    /wsn
  195.     { dup null eq
  196.        { pop (\t255,255,) wl
  197.        }
  198.        { dup type /nametype eq { wnstring cvs } if
  199.      dup type /stringtype ne { cvos (255,) ws } if
  200.      dup length 256 idiv wt (,) ws
  201.      dup length 256 mod wt
  202.      (,) (,\n) wca
  203.        }
  204.       ifelse
  205.     } bind def
  206. % Write a packed string/name/null array.
  207.    /wsna    % <name> <(string|name|null)*> wsna -
  208.     { (\tstatic const char ) ws exch wt ([] = {) wl
  209.       { wsn } forall
  210.       (\t0\n};) wl
  211.     } bind def
  212.  
  213. % Write a number or an array of numbers, as refs.
  214. /isnumber
  215.  { type dup /integertype eq exch /realtype eq or
  216.  } bind def
  217. /wnums
  218.  { dup isnumber
  219.     { (real_v\() ws wt (\),) ws }
  220.     { { wnums } forall }
  221.    ifelse
  222.  } bind def
  223.  
  224. % Test whether a procedure or unusual array can be written (printed).
  225. /iswx 4 dict dup begin
  226.   /arraytype { { iswproc } isall } def
  227.   /nametype { pop true } def
  228.   /operatortype { pop true } def    % assume it has been bound in
  229.   /packedarraytype /arraytype load def
  230. end def
  231. /iswnx 6 dict dup begin
  232.   /arraytype { { iswproc } isall } def
  233.   /integertype { pop true } def
  234.   /nametype { pop true } def
  235.   /realtype { pop true } def
  236.   /stringtype { pop true } def
  237.   /packedarraytype /arraytype load def
  238. end def
  239. /iswproc    % <obj> iswproc <bool>
  240.  { dup xcheck { iswx } { iswnx } ifelse
  241.    1 index type .knownget { exec } { pop false } ifelse
  242.  } bind def
  243.  
  244. % Write a printable procedure (one for which iswproc returns true).
  245. /wproca 3 dict dup begin
  246.   /arraytype
  247.    { 1 index ({) writestring
  248.       { 1 index ( ) writestring 1 index exch wproc } forall
  249.      (}) writestring
  250.    } bind def
  251.   /packedarraytype /arraytype load def
  252.   /operatortype { .writecvs } bind def    % assume binding would work
  253. end def
  254. /wproc        % <file> <proc> wproc -
  255.  { dup type wproca exch .knownget { exec } { write==only } ifelse
  256.  } bind def
  257.  
  258. % Write a named object.  Return true if this was possible.
  259. % Legal types are: boolean, integer, name, real, string,
  260. % array of (integer, integer+real, name, null+string),
  261. % and certain procedures and other arrays (see iswproc above).
  262. % All other objects are either handled specially or ignored.
  263.    /isall    % <array> <proc> isall <bool>
  264.     { true 3 -1 roll
  265.        { 2 index exec not { pop false exit } if }
  266.       forall exch pop
  267.     } bind def
  268.    /wott 8 dict dup begin
  269.       /arraytype
  270.        { woatt
  271.           { aload pop 2 index 2 index exec
  272.          { exch pop exec exit }
  273.          { pop pop }
  274.         ifelse
  275.       }
  276.      forall
  277.        } bind def
  278.       /booleantype
  279.        { { (\tmake_true\(&) } { (\tmake_false\(&) } ifelse ws
  280.          wt (\);) wl true
  281.        } bind def
  282.       /integertype
  283.        { (\tmake_int\(&) ws exch wt (, ) ws
  284.          wt (\);) wl true
  285.        } bind def
  286.       /nametype
  287.        { (\tcode = (*pprocs->name_create)\(&) ws exch wt
  288.          (, ) ws wnstring cvs wcs    % OK, names are short
  289.      (\);) wl
  290.      (\tif ( code < 0 ) return code;) wl
  291.      true
  292.        } bind def
  293.       /packedarraytype
  294.     /arraytype load def
  295.       /realtype
  296.        { (\tmake_real\(&) ws exch wt (, ) ws
  297.          wt (\);) wl true
  298.        } bind def
  299.       /stringtype
  300.        { ({\tstatic const char s_[] = ) ws
  301.          dup dup can_wcs { wcs } { wcca } ifelse
  302.      (;) wl
  303.      (\tmake_const_string\(&) ws exch wt
  304.      (, a_readonly, ) ws length wt (, (const byte *)s_\);) wl
  305.      (}) wl true
  306.        } bind def
  307.    end def
  308. % Write some other kind of object, if known.
  309.    /wother
  310.     { dup otherobjs exch known
  311.        { otherobjs exch get (\t) ws exch wt ( = ) ws wt (;) wl true }
  312.        { pop pop false }
  313.       ifelse
  314.     } bind def
  315. % Top-level procedure.
  316.    /wo        % name obj -> OK
  317.     { dup type wott exch .knownget { exec } { wother } ifelse
  318.     } bind def
  319.  
  320. % Write an array (called by wo).
  321.    /wap        % <name> <array> wap -
  322.     { dup xcheck not 1 index wcheck not and 1 index rcheck and
  323.        { pop pop }
  324.        { (\tr_set_attrs\(&) ws exch wt (, ) ws wpa (\);) wl }
  325.       ifelse
  326.     } bind def
  327.    /wnuma    % <name> <array> <element_C_type> <<type>_v> wnuma -
  328.     { 2 index wcheck
  329.        {    % Allocate an array and copy the values into it.
  330.         % We can't define new callback procedures, so we must
  331.         % do this the hard way.
  332.      pop pop
  333.      ({\tstatic const byte z_[) ws dup length 1 .max 2 mul wt
  334.      (] = {0}; ref r_;) wl
  335.      (\tcode = (*pprocs->string_array_create)\(&r_, z_, ) ws
  336.      dup length wt (, 0\);) wl
  337.      (\tif ( code < 0 ) return code;) wl
  338.      (\tr_set_attrs\(&r_, ) ws dup wpa (\);) wl
  339.      (\t) ws exch wt ( = r_;) wl
  340.      0 1 2 index length 1 sub
  341.       { 2 copy get
  342.         % Stack: array index value
  343.         dup type /integertype eq { (\tmake_int) } { (\tmake_real) } ifelse
  344.         ws (_new\(&r_.value.refs[) ws exch wt
  345.         (], ) ws wt (\);) wl
  346.       }
  347.      for pop
  348.        }
  349.        { ({\tstatic const ref_\() ws exch ws
  350.      (\) a_[] = {) wl exch
  351.      dup length 0 eq
  352.       { (\t) ws 1 index ws (\(0\)) wl
  353.       }
  354.       { dup
  355.          { (\t) ws 2 index ws (\() ws wt (\),) wl
  356.          } forall
  357.       }
  358.      ifelse exch pop
  359.      (\t};) wl
  360.      (\tmake_const_array\(&) ws exch wt
  361.          (, avm_foreign|) ws dup wpa (, ) ws length wt
  362.          (, (const ref *)a_\);) wl
  363.        }
  364.       ifelse
  365.       (}) wl
  366.     } bind def
  367.    /woatt [
  368.     % Integers
  369.      { { { type /integertype eq } isall }
  370.        { (long) (integer_v) wnuma true }
  371.      }
  372.     % Integers + reals
  373.      { { { type dup /integertype eq exch /realtype eq or } isall }
  374.        { (float) (real_v) wnuma true }
  375.      }
  376.     % Strings + nulls
  377.      { { { type dup /nulltype eq exch /stringtype eq or } isall }
  378.        { ({) ws dup (sa_) exch wsna
  379.      (\tcode = (*pprocs->string_array_create)\(&) ws exch wt
  380.      (, sa_, ) ws dup length wt (, ) ws wpa (\);) wl
  381.      (\tif ( code < 0 ) return code;) wl
  382.      (}) wl true
  383.        }
  384.      }
  385.     % Names
  386.      { { { type /nametype eq } isall }
  387.        { ({) ws dup (na_) exch wsna
  388.      (\tcode = (*pprocs->name_array_create)\(&) ws 1 index wt
  389.      (, na_, ) ws dup length wt (\);) wl
  390.      (\tif ( code < 0 ) return code;) wl
  391.      wap (}) wl true
  392.        }
  393.      }
  394.     % Procedure
  395.      { { iswproc }
  396.        { dup cvos
  397.         % Stack: name proc string
  398.      ({\tstatic const char s_[] = ) ws
  399.          dup dup can_wcs { wcs } { wcca } ifelse
  400.      (;) wl
  401.      (\tcode = (*pprocs->ref_from_string)\(&) ws 2 index wt
  402.      (, s_, ) ws length wt (\);) wl
  403.      (\tif ( code < 0 ) return code;) wl
  404.      wap (}) wl true
  405.      wtempname deletefile
  406.        }
  407.      }
  408.     % Default
  409.      { { pop true }
  410.        { wother }
  411.      }
  412.    ] def
  413.  
  414. % Write a named dictionary.  We assume the ref is already declared.
  415.    /wd        % <name> <dict> <extra> wd -
  416.     { 3 1 roll
  417.       ({) ws
  418.       (\tref v_[) ws dup length wt (];) wl
  419.       dup [ exch
  420.        { counttomark 2 sub wtstring cvs
  421.          (v_[) exch concatstrings (]) concatstrings exch wo not
  422.           { (Skipping ) print ==only (....\n) print }
  423.      if
  424.        } forall
  425.       ]
  426.         % Stack: array of keys (names)
  427.       ({) ws dup (str_keys_) exch wsna
  428.       (\tstatic const cfont_dict_keys keys_ =) wl
  429.       (\t { 0, 0, ) ws length wt (, ) ws 3 -1 roll wt (, ) ws
  430.       dup wpa (, ) ws dup wva ( };) wl pop
  431.       (\tcode = \(*pprocs->ref_dict_create\)\(&) ws wt
  432.       (, &keys_, str_keys_, v_\);) wl
  433.       (\tif ( code < 0 ) return code;) wl
  434.       (}) wl
  435.       (}) wl
  436.     } bind def
  437.  
  438. % Write character dictionary keys.
  439. % We save a lot of space by abbreviating keys which appear in
  440. % StandardEncoding or ISOLatin1Encoding.
  441. % Writes code to declare and initialize enc_keys_, str_keys, and keys_.
  442. /wcdkeys    % <dict> wcdkeys -
  443.  {    % Write keys present in StandardEncoding or ISOLatin1Encoding,
  444.     % pushing other keys on the o-stack.
  445.    (static const charindex enc_keys_[] = {) wl
  446.    dup [ exch 0 exch
  447.     { pop decoding 1 index known
  448.        { decoding exch get ({) ws dup -8 bitshift wt
  449.      (,) ws 255 and wt (}, ) ws
  450.      1 add dup 5 mod 0 eq { (\n) ws } if
  451.        }
  452.        { exch }
  453.       ifelse
  454.     }
  455.    forall pop
  456.    ]
  457.    ({0,0}\n};) wl
  458.     % Write other keys.
  459.    (str_keys_) exch wsna
  460.     % Write the declaration for keys_.
  461.    (static const cfont_dict_keys keys_ = {) wl
  462.    (\tenc_keys_, countof\(enc_keys_\) - 1,) wl
  463.    (\t) ws dup length wt ( - \(countof\(enc_keys_\) - 1\), 0, ) ws
  464.    dup wpa (, ) ws wva () wl
  465.    (};) wl
  466.  } bind def
  467.  
  468. % Enumerate character dictionary values in the same order that
  469. % the keys appear in enc_keys_ and str_keys_.
  470. % <proc> is called with each value in turn.
  471. /cdforall    % <dict> <proc> cdforall -
  472.  { 2 copy
  473.     { decoding 3 index known
  474.        { 3 -1 roll pop exec }
  475.        { pop pop pop }
  476.       ifelse
  477.     }
  478.    /exec cvx 3 packedarray cvx
  479.    /forall cvx
  480.    5 -2 roll
  481.     { decoding 3 index known
  482.        { pop pop pop }
  483.        { 3 -1 roll pop exec }
  484.       ifelse
  485.     }
  486.    /exec cvx 3 packedarray cvx
  487.    /forall cvx
  488.    6 packedarray cvx exec
  489.  } bind def
  490.  
  491. % ------ Writers for special objects ------ %
  492.  
  493. /writespecial 10 dict dup begin
  494.  
  495.    /FontInfo { 0 wd } def
  496.  
  497.    /Private { 0 wd } def
  498.  
  499.    /CharStrings
  500.     { ({) wl
  501.       dup wcdkeys
  502.       (static const char values_[] = {) wl
  503.        { wsn } cdforall
  504.       (\t0\n};) wl
  505.       (\tcode = \(*pprocs->string_dict_create\)\(&) ws wt
  506.       (, &keys_, str_keys_, values_\);) wl
  507.       (\tif ( code < 0 ) return code;) wl
  508.       (}) wl
  509.     } bind def
  510.  
  511.    /Metrics
  512.     { ({) wl
  513.       dup wcdkeys
  514.       (static const ref_(float) values_[] = {) wl
  515.       dup { (\t) ws wnums () wl } cdforall
  516.       (\t0\n};) wl
  517.       (static const char lengths_[] = {) wl
  518.        { (\t) ws dup isnumber
  519.       { pop 0 }
  520.       { length 1 add }
  521.      ifelse wt (,) wl
  522.        } cdforall
  523.       (\t0\n};) wl
  524.       (\tcode = \(*pprocs->num_dict_create\)\(&) ws wt
  525.       (, &keys_, str_keys_, (const ref *)values_, lengths_\);) wl
  526.       (\tif ( code < 0 ) return code;) wl
  527.       (}) wl
  528.     } bind def
  529.  
  530.    /Metrics2 /Metrics load def
  531.  
  532.    /FDepVector pop    % (converted to a list of font names)
  533.  
  534. end def
  535.  
  536. % ------ The main program ------ %
  537.  
  538. % Construct an inverse dictionary of encodings.
  539. [ /StandardEncoding /ISOLatin1Encoding
  540.   /SymbolEncoding /DingbatsEncoding
  541.   /KanjiSubEncoding
  542. ]
  543. dup length dict begin
  544.  { mark exch dup { .findencoding exch def } stopped cleartomark
  545.  } forall
  546. currentdict end /encodingnames exch def
  547.  
  548. % Invert the StandardEncoding and ISOLatin1Encoding vectors.
  549. 512 dict begin
  550.   0 1 255 { dup ISOLatin1Encoding exch get exch 256 add def } for
  551.   0 1 255 { dup StandardEncoding exch get exch def } for
  552. currentdict end /decoding exch def
  553.  
  554. /writefont        % cfilename procname -> [writes the current font]
  555.  { (gsf_) exch concatstrings
  556.      /fontprocname exch def
  557.    /cfname exch def
  558.    /cfile cfname (w) file def
  559.  
  560. % Remove unwanted keys from the font.
  561.    currentfont dup length dict begin { def } forall
  562.     { /FID /MIDVector /CurMID } { currentdict exch undef } forall
  563.    /Font currentdict end def
  564.  
  565. % Replace the FDepVector with a list of font names.
  566.    Font /FDepVector .knownget
  567.     { [ exch { /FontName get } forall ]
  568.       Font /FDepVector 3 -1 roll put
  569.     }
  570.    if
  571.  
  572. % Find all the special objects we know about.
  573. % wo uses this to write out references to otherwise intractable objects.
  574.    /otherobjs writespecial length dict dup begin
  575.      writespecial
  576.       { pop Font 1 index .knownget { exch def } { pop } ifelse
  577.       }
  578.      forall
  579.    end def
  580.  
  581. % Define a dummy FontInfo, in case the font doesn't have one.
  582.    /FontInfo 0 dict def
  583.  
  584. % Write out the boilerplate.
  585.    Font begin
  586.    (/****************************************************************) wl
  587.    (   Portions of this file are subject to the following notice(s):) wl
  588.    systemdict /copyright get wl
  589.    FontInfo /Notice .knownget
  590.     { (----------------------------------------------------------------) wl wl
  591.     } if
  592.    (****************************************************************/) wl
  593.    () wl
  594.    (/* ) ws cfname ws ( */) wl
  595.    (/* This file was created by the ) ws product ws ( font2c utility. */) wl
  596.    () wl
  597.    (#undef DEBUG) wl
  598.    (#include "ccfont.h") wl
  599.    () wl
  600.  
  601. % Write the procedure prologue.
  602.    (#ifdef __PROTOTYPES__) wl
  603.    (int huge) wl
  604.    fontprocname ws ((const cfont_procs *pprocs, ref *pfont)) wl
  605.    (#else) wl
  606.    (int huge) wl
  607.    fontprocname ws ((pprocs, pfont) const cfont_procs *pprocs; ref *pfont;) wl
  608.    (#endif) wl
  609.    ({\tint code;) wl
  610.    (\tref Font;) wl
  611.    otherobjs
  612.     { exch pop (\tref ) ws wt (;) wl }
  613.    forall
  614.  
  615. % Write out the special objects.
  616.    otherobjs
  617.     { exch writespecial 2 index get exec
  618.     }
  619.    forall
  620.  
  621. % Write out the main font dictionary.
  622. % If possible, substitute the encoding name for the encoding;
  623. % PostScript code will fix this up.
  624.     { /Encoding /PrefEnc }
  625.     { Font 1 index .knownget
  626.        { encodingnames exch .knownget { def } { pop } ifelse }
  627.        { pop }
  628.       ifelse
  629.     }
  630.    forall
  631.    (Font) Font FontType 0 eq { 5 } { 1 } ifelse wd
  632.  
  633. % Finish the procedural initialization code.
  634.    (\t*pfont = Font;) wl
  635.    (\treturn 0;) wl
  636.    (}) wl
  637.    end                % Font
  638.  
  639.    cfile closefile
  640.  
  641.  } bind def
  642.  
  643. end def            % font2cdict
  644.  
  645. % Compute the procedure name from the font name.
  646. % Replace all non-alphanumeric characters with '_'.
  647. /makefontprocnamemap 256 string
  648.    0 1 255 { 2 copy 95 put pop } for
  649.    (0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz)
  650.     { 2 copy dup put pop } forall
  651. readonly def
  652. /makefontprocname    % <fontname> makefontprocname <procnamestring>
  653.  { dup length string cvs
  654.    dup length 1 sub -1 0
  655.     {        % Stack: string index
  656.       2 copy 2 copy get //makefontprocnamemap exch get put pop
  657.     }
  658.    for 
  659.  } def
  660.  
  661. /writefont { font2cdict begin writefont end } def
  662.  
  663. % If the program was invoked from the command line, run it now.
  664. [ shellarguments
  665.  { counttomark dup 2 eq exch 3 eq or
  666.     { counttomark -1 roll cvn
  667.       (Converting ) print dup =only ( font.\n) print flush
  668.       dup FontDirectory exch known { dup FontDirectory exch undef } if
  669.       findfont setfont
  670.       (FontName is ) print currentfont /FontName get ==only (.\n) print flush
  671.       counttomark 1 eq
  672.        {    % Construct the procedure name from the file name.
  673.          currentfont /FontName get makefontprocname
  674.        }
  675.       if
  676.       writefont
  677.       (Done.\n) print flush
  678.     }
  679.     { cleartomark
  680.       (Usage: font2c fontname cfilename.c [shortname]\n) print
  681.       ( e.g.: font2c Courier cour.c\n) print flush
  682.       mark
  683.     }
  684.    ifelse
  685.  }
  686. if pop
  687.